home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / back_end / reg.t < prev    next >
Encoding:
Text File  |  1990-04-12  |  12.6 KB  |  358 lines
  1. (herald (back_end reg)
  2.   (env t (orbit_top defs) (back_end closure) (back_end bookkeep)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.  
  29. (define (generate-init continuation)
  30.   (bind ((*unit-literals* '())
  31.          (*unit-variables* '())
  32.          (*unit-closures* '())
  33.          (*unit-templates* '())
  34.          (*unit* nil) 
  35.          (*registers* (vector-fill (make-vector *virtual-registers*) nil))
  36.          (*lambda* nil)
  37.          (*heap-env* 0)
  38.          (*locations* (make-table 'locations))
  39.          (*lambda-queue* '()))
  40.     (continuation)))
  41.  
  42.  
  43. (define (generate top-node)
  44.   (generate-code (car (call-args (lambda-body top-node)))))
  45.  
  46. (lset *assembly-comments?* nil)
  47. (lset *lambda-queue* '())         ;; queue of lambda bodies to process
  48. (lset *heap-env* nil)              ;; distance of stack-pointer from "frame"
  49. (lset *max-temp* 0)               ;; maximum number of temporaries used
  50. (lset *lambda* nil)               ;; the procedure being compiled
  51. (lset *call-break?* nil)           
  52. (lset *registers* nil)
  53.  
  54. (define-local-syntax (ass-comment string . rest)
  55.   `(if *assembly-comments?*
  56.        (emit-comment (format nil ,string ,@rest))))                      
  57.  
  58. ;;; GENERATE-CODE Initialize lambda queue. Go.
  59.  
  60. (define (generate-code node)
  61.   (set (lambda-max-temps node) 0)
  62.   (allocate-registers node)
  63.   (process-lambda-queue))
  64.  
  65. (define (generate-code-for-object node)
  66.   (set *heap-env* node)
  67.   (let ((object-proc ((call-arg 2) (lambda-body node))))
  68.     (set *lambda* object-proc)
  69.     (emit-template node object-proc)
  70.     (set (lambda-max-temps object-proc) 0)
  71.     (if (closure-env (environment-closure (lambda-env node)))
  72.         (mark (lambda-self-var node) P))
  73.     (maybe-allocate-red-frame object-proc)
  74.     (if (n-ary? object-proc)
  75.         (n-ary-setup object-proc))
  76.     (mark-vars-in-regs (cdr (lambda-variables object-proc)))
  77.     (allocate-call (lambda-body object-proc))
  78.     (emit-tag object-proc)
  79.     (generate-handler node object-proc))
  80.   (process-lambda-queue))
  81.  
  82.  
  83. (define (lambda-queue node)
  84.   (push *lambda-queue* node))
  85.  
  86. (define (process-lambda-queue)
  87.   (if *lambda-queue*
  88.       (let ((thing (pop *lambda-queue*)))
  89.         (xcond ((object-lambda? thing)
  90.                 (generate-code-for-object thing))
  91.                ((lambda-node? thing)     
  92.                 (generate-code thing))
  93.                ((lap-template-struct? thing)
  94.                 (process-lap-template thing))))))
  95.  
  96. ;;; ALLOCATE-REGISTERS Sets *lambda* to be the lambda-node representing the
  97. ;;; environment the node argument is compiled in.  Generate code for the body.
  98.  
  99. (define (allocate-registers node)
  100.   (xselect (lambda-strategy node)
  101.     ((strategy/heap)
  102.      (set *lambda* node)
  103.      (set *heap-env* node)
  104.      (ass-comment "Procedure ~s (lambda ~s ...)" 
  105.           (lambda-name node)
  106.           (append! (map variable-unique-name (lambda-variables node))
  107.                (cond ((lambda-rest-var node) => variable-unique-name)
  108.                  (else '()))))
  109.      (emit-template node node)
  110.      (maybe-allocate-red-frame node))
  111.     ((strategy/label)
  112.      (emit-tag node)
  113.      (set *heap-env* (variable-binder (join-point-contour (lambda-env node))))
  114.      (cond ((fully-recursive? node)
  115.         (set *lambda* node)
  116.         (maybe-allocate-red-frame node))
  117.        (else
  118.         (set *lambda* (join-point-*lambda* (lambda-env node)))))))
  119.   (if (n-ary? node)
  120.       (n-ary-setup node))
  121.   (initialize-registers node)
  122.   (allocate-call (lambda-body node)))
  123.     
  124. (define-constant (maybe-allocate-red-frame node)
  125.   (emit maybe-pushfr node))
  126.  
  127. ;;; INITIALIZE-REGISTERS Here we mark the arguments of a closure as being in
  128. ;;; the argument registers.  For a heaped lambda there is also the environment
  129. ;;; in the P register.  For a join point the state is initialized.
  130.  
  131. (define-integrable (method-lambda node)
  132.   (let ((p (node-parent node)))
  133.     (if (primop-ref? (call-proc p) primop/proc+handler)
  134.         (node-parent p)
  135.         nil)))
  136.    
  137. (define (initialize-registers node)
  138.   (xselect (lambda-strategy node)
  139.     ((strategy/heap)
  140.      (cond ((method-lambda node)
  141.             => (lambda (obj)
  142.                  (mark (lambda-self-var obj) P)
  143.                  (set *heap-env* obj)))
  144.            (else
  145.             (mark (lambda-self-var node) P)))
  146.      (mark-vars-in-regs (cdr (lambda-variables node))))
  147.     ((strategy/label)
  148.      (ass-comment "Label procedure ~s (lambda ~s ...)" 
  149.              (lambda-name node)
  150.              (map variable-unique-name (lambda-variables node)))
  151.      (walk mark
  152.           (if (continuation? node)
  153.               (lambda-variables node)
  154.               (cdr (lambda-variables node)))
  155.           (join-point-arg-specs (lambda-env node)))
  156.      (walk (lambda (pair)
  157.              (mark (cdr pair) (car pair)))
  158.            (join-point-global-registers (lambda-env node))))))
  159.  
  160.  
  161.  
  162. (define (mark-vars-in-regs vars)
  163.   (do ((vars vars (cdr vars))
  164.        (reg A1 (fx+ reg 1)))
  165.       ((or (fx>= reg AN) (null? vars))
  166.        (cond (vars
  167.           (do ((vars vars (cdr vars))
  168.            (reg *first-stack-register* (fx+ reg 1)))
  169.           ((null? vars)
  170.            (modify (lambda-max-temps *lambda*)
  171.                (lambda (temps) (max temps (fx- reg 1)))))
  172.         (cond ((and (car vars) (variable-refs (car vars)))
  173.                (mark (car vars) reg)
  174.                (generate-extra-arg-move reg)))))))
  175.     (cond ((and (car vars) (variable-refs (car vars)))
  176.            (mark (car vars) reg)))))
  177.  
  178.      
  179. ;;; A closure is n-ary if it has a non null rest arg.
  180.  
  181. (define n-ary? lambda-rest-var)
  182.  
  183. (define (n-ary-setup node)
  184.   (cond ((not (used? (lambda-rest-var node))))
  185.     (else
  186.      (xselect (lambda-strategy node)
  187.        ((strategy/heap)
  188.         (generate-nary-setup node (length (cdr (lambda-variables node)))))
  189.        ((strategy/label)
  190.         (mark (lambda-rest-var node) AN))))))
  191.  
  192.  
  193.  
  194.  
  195. (define (allocate-primop-call node)
  196.   (let* ((prim (primop-value (call-proc node))))
  197.     (cond ((primop.conditional? prim)
  198.            (allocate-conditional-primop node prim))
  199.       ((eq? prim primop/computed-goto)
  200.        (allocate-computed-goto node prim))
  201.           ((primop.special? prim)
  202.            (primop.generate prim node))
  203.           (else           
  204.            (really-allocate-primop-call node prim)))))
  205.  
  206. (define (allocate-computed-goto node prim)
  207.   (let ((reg (->register node (leaf-value (index-ref node)))))
  208.     (emit-goto reg)
  209.     (do ((i (call-exits node) (fx- i 1))
  210.      (next (call-args node) (cdr next)))
  211.     ((fx= i 0))
  212.       (emit-branch (car next))
  213.       (emit-noop))
  214.     (let ((+registers+ *registers*)
  215.       (+heap-env+ *heap-env*)
  216.       (+lambda+ *lambda*))
  217.       (iterate loop ((i (call-exits node)) (next (call-args node)))
  218.     (cond ((fx= i 0))
  219.           (else
  220.            (set *registers* (copy-registers))
  221.            (set *heap-env* +heap-env+)
  222.            (set *lambda* +lambda+)
  223.            (emit-tag (car next))
  224.            (walk (lambda (n)
  225.                (kill-if-dead n (car next)))
  226.              (cdr next))
  227.            (allocate-call (lambda-body (car next)))
  228.            (return-registers)
  229.            (set *registers* +registers+)
  230.            (restore-slots)
  231.            (loop (fx- i 1) (cdr next))))))))
  232.  
  233. (define-constant (index-ref node)
  234.   ((call-arg (fx+ (call-exits node) 1)) node))
  235.  
  236.                                        
  237.  
  238. ;;; ALLOCATE-CONDITIONAL-PRIMOP When we come to a split we save the state of
  239. ;;; the world and traverse one arm, then restore the state and traverse the
  240. ;;; other.
  241.  
  242. (define (allocate-conditional-primop node prim)
  243.   (primop.generate prim node)      
  244.   (let ((then (then-cont node))
  245.         (else (else-cont node)))
  246.   (receive (then else) (cond ((or (leaf-node? then) 
  247.                                   (leaf-node? else) 
  248.                                   (fx< (lambda-trace then)
  249.                                        (lambda-trace else)))
  250.                               (return then else))
  251.                              (t
  252.                               (return else then)))
  253.     (let ((registers (swap *registers* (copy-registers)))
  254.       (lam *lambda*)
  255.       (heap-env *heap-env*))
  256.       (emit-tag then)  
  257.       (cond ((lambda-node? then)
  258.              (walk (lambda (n)
  259.                      (kill-if-dead n then))
  260.                    (cons else (cddr (call-args node))))
  261.              (allocate-call (lambda-body then)))
  262.             (t
  263.              (allocate-conditional-continuation node then)))
  264.       (return-registers)
  265.       (set *lambda* lam)
  266.       (set *heap-env* heap-env)
  267.       (set *registers* registers))
  268.     (restore-slots)
  269.     (emit-tag else)  
  270.     (cond ((lambda-node? else)
  271.            (walk (lambda (n)
  272.                    (kill-if-dead n else))
  273.                  (cons then (cddr (call-args node))))
  274.            (allocate-call (lambda-body else)))
  275.           (t
  276.            (allocate-conditional-continuation node else))))))
  277.                                         
  278. ;; We must decide whether to try to delay dereferencing the location.
  279. ;; We do this if the value is used just once and in the next frob and
  280. ;; is an operand to a primop.
  281.  
  282.  
  283. (define (really-allocate-primop-call node prim)
  284.   (let ((c (cont node)))
  285.     (cond ((lambda-node? c)
  286.            (primop.generate prim node)
  287.            (walk (lambda (node)
  288.                    (kill-if-dead node c))
  289.                  (cdr (call-args node)))
  290.            (allocate-call (lambda-body c)))
  291.           (else                            
  292.            (primop.generate prim node)
  293.            (walk (lambda (node)
  294.                    (if (leaf-node? node) (kill (leaf-value node))))
  295.                  (cdr (call-args node)))
  296.        (maybe-deallocate-red-frame *lambda*)
  297.            (clear-slots)
  298.            (let ((j (variable-known (leaf-value c))))
  299.              (if j
  300.                  (bug "known continuation to primop ~s" j)
  301.                  (generate-return (primop.values-returned prim))))))))
  302.  
  303.  
  304.  
  305. (define (access/make-closure node lam)
  306.   (let* ((closure (environment-closure (lambda-env lam))))
  307.     (cond ((eq? closure *unit*)
  308.            (lambda-queue lam)
  309.            (->register node lam))
  310.           (else
  311.            (make-heap-closure node closure)
  312.            AN))))
  313.  
  314.  
  315.  
  316. (define (do-trivial-lambda node reg)
  317.   (let ((offset (environment-cic-offset (lambda-env node))))
  318.     (cond ((fx= offset 0)
  319.            (generate-move AN reg))
  320.           (else                   
  321.            (generate-move-address (reg-offset AN offset) reg)))
  322.     (cond ((reg-node  reg)
  323.                 => kill))
  324.     (lock reg)))
  325.  
  326.  
  327. ;;; MAKE-HEAP-CLOSURE The first member of the closure corresponds to the
  328. ;;; template so we call %make-extend with this template and the size of the
  329. ;;; closure to be created.  Then we fill in the slots with the need variables
  330. ;;; and the addresses of templates for any closure-internal-closures.
  331.  
  332. (define (make-heap-closure node closure)
  333.   (if *assembly-comments?* (emit-comment "consing heap closure"))
  334.   (let* ((members (closure-members closure))
  335.          (template-binder (variable-binder (car members))))
  336.     (walk (lambda (var)
  337.             (lambda-queue (variable-binder var)))
  338.           members)
  339.     (free-register node AN)
  340.     (generate-move-pcrel template-binder AN)
  341.     (lock AN)
  342.     (generate-extend node (closure-size closure))
  343.     (walk (lambda (pair)
  344.         (let ((var (car pair))
  345.               (offset (cdr pair)))
  346.           (cond ((eq? var *dummy-var*))
  347.                 ((memq? var members)
  348.                  (generate-move-pcrel (variable-binder var)
  349.                       (reg-offset AN (fx- offset tag/extend))))
  350.                 (else
  351.                  (generate-move (lookup-value node var)
  352.                 (reg-offset AN (fx- offset tag/extend)))))))
  353.         (cdr (closure-env closure))))
  354.   (unlock AN))
  355.  
  356. (define exchange-hack false)
  357.  
  358.